home *** CD-ROM | disk | FTP | other *** search
/ Acorn User: China / Acorn User China CD-ROM (UK) (Disc A) / Acorn User China CD-ROM (UK) (Disc A).bin / HENSA / MATHS / PGPLOT.ARC / Examples_f77_PGDEMO4 < prev    next >
Encoding:
Text File  |  1997-06-06  |  10.7 KB  |  367 lines
  1.       PROGRAM PGDEM4
  2. C-----------------------------------------------------------------------
  3. C Test program for PGPLOT: test of imaging routine PGIMAG and associated
  4. C routines PGWEDG and PGCTAB.
  5. C-----------------------------------------------------------------------
  6.       INTEGER PGOPEN
  7.       INTEGER   MXI, MXJ
  8.       PARAMETER (MXI=64, MXJ=64)
  9.       INTEGER I, L, C1, C2, NC
  10.       REAL F(MXI,MXJ)
  11.       REAL FMIN,FMAX,TR(6), CONTRA, BRIGHT, ANGLE, C, S, ALEV(1)
  12.       CHARACTER*16 VAL
  13. C
  14. C Introduction.
  15. C
  16.       WRITE(*,*)'Demonstration of PGIMAG and associated routines.'
  17.       WRITE(*,*)'This program requires a device with color capability.'
  18.       WRITE(*,*)'On an interactive device, you can modify the color map'
  19.       WRITE(*,*)'used for the image.'
  20.       WRITE(*,*)
  21. C
  22. C Open device for graphics.
  23. C
  24.       IF (PGOPEN('?') .LT. 1) STOP
  25.       CALL PGQINF('TYPE', VAL, L)
  26.       WRITE (*,*) 'PGPLOT device type: ', VAL(1:L)
  27.       CALL PGQCIR(C1, C2)
  28.       NC = MAX(0, C2-C1+1)
  29.       WRITE (*,*) 'Number of color indices used for image: ', NC
  30.       IF (NC .LT.8) THEN 
  31.          WRITE (*,*) 'Not enough colors available on this device'
  32.          STOP
  33.       ELSE
  34.          WRITE (*,*)
  35.       END IF
  36. C
  37. C Compute a suitable function in array F.
  38. C
  39.       CALL FUNC(F, MXI, MXJ, FMIN, FMAX)
  40. C
  41. C-----------------------------------------------------------------------
  42. C Example 1: simple transformation matrix
  43. C-----------------------------------------------------------------------
  44. C
  45. C Set the coordinate transformation matrix: 
  46. C world coordinate = pixel number.
  47. C
  48.       TR(1) = 0.0
  49.       TR(2) = 1.0
  50.       TR(3) = 0.0
  51.       TR(4) = 0.0
  52.       TR(5) = 0.0
  53.       TR(6) = 1.0
  54. C
  55. C Clear the screen. Set up window and viewport.
  56. C
  57.       CALL PGPAGE
  58.       CALL SETVP
  59.       CALL PGWNAD(0.0, 1.0+MXI, 0.0, 1.0+MXJ)
  60. C
  61. C Set up the color map.
  62. C
  63.       BRIGHT = 0.5
  64.       CONTRA  = 1.0
  65.       CALL PALETT(2, CONTRA, BRIGHT)
  66. C
  67. C Draw the map with PGIMAG.  
  68. C
  69.       CALL PGIMAG(F,MXI,MXJ,1,MXI,1,MXJ,FMIN,FMAX,TR)
  70. C
  71. C Annotate the plot.
  72. C
  73.       CALL PGMTXT('t',1.0,0.0,0.0,'PGIMAG, PGWEDG, and PGCTAB')
  74.       CALL PGSCH(0.6)
  75.       CALL PGBOX('bcntsi',0.0,0,'bcntsiv',0.0,0)
  76.       CALL PGMTXT('b',3.0,1.0,1.0,'pixel number')
  77. C
  78. C Draw a wedge.
  79. C
  80.       CALL PGWEDG('BI', 4.0, 5.0, FMIN, FMAX, 'pixel value')
  81.       CALL PGSCH(1.0)
  82. C
  83. C If the device has a cursor, allow user to fiddle with color table.
  84. C
  85.       CALL PGQINF('CURSOR', VAL, L)
  86.       IF (VAL(:L).EQ.'YES') THEN
  87.          CALL FIDDLE
  88.          CALL PGASK(.FALSE.)
  89.       END IF
  90. C
  91. C-----------------------------------------------------------------------
  92. C Example 2: rotation, overlay contours.
  93. C-----------------------------------------------------------------------
  94. C
  95. C Compute the coordinate transformation matrix. The matrix is chosen
  96. C to put array element (MXI/2, MXJ/2) at (X,Y)=(0,0), and map the
  97. C entire array onto a square of side 2, rotated through angle ANGLE
  98. C radians.
  99. C
  100.       ANGLE = 120.0/57.29578
  101.       C = COS(ANGLE)
  102.       S = SIN(ANGLE)
  103.       TR(1) = -C - S
  104.       TR(2) = 2.0*C/REAL(MXI)
  105.       TR(3) = 2.0*S/REAL(MXJ)
  106.       TR(4) = -C + S
  107.       TR(5) = (-2.0)*S/REAL(MXI)
  108.       TR(6) = 2.0*C/REAL(MXJ)
  109. C
  110. C Clear the screen. Set up window and viewport.
  111. C
  112.       CALL PGPAGE
  113.       CALL SETVP
  114.       CALL PGWNAD(-1.0, 1.0, -1.0, 1.0)
  115.       CALL PGSCI(1)
  116. C
  117. C Set up the color map.
  118. C
  119.       BRIGHT = 0.5
  120.       CONTRA  = 1.0
  121.       CALL PALETT(2, CONTRA, BRIGHT)
  122. C
  123. C Draw the map with PGIMAG.  
  124. C
  125.       CALL PGIMAG(F,MXI,MXJ,1,MXI,1,MXJ,FMIN,FMAX,TR)
  126. C
  127. C Overlay contours in white.
  128. C
  129.       CALL PGSCI(1)
  130.       DO 40 I=1,21
  131.           ALEV(1) = FMIN + (I-1)*(FMAX-FMIN)/20.0
  132.           IF (MOD(I,5).EQ.0) THEN
  133.               CALL PGSLW(3)
  134.           ELSE
  135.               CALL PGSLW(1)
  136.           END IF
  137.           IF (I.LT.10) THEN
  138.               CALL PGSLS(2)
  139.           ELSE
  140.               CALL PGSLS(1)
  141.           END IF
  142.           CALL PGCONT(F,MXI,MXJ,1,MXI,1,MXJ,ALEV,-1,TR)
  143.    40 CONTINUE
  144.       CALL PGSLS(1)
  145.       CALL PGSLW(1)
  146. C
  147. C Annotate the plot.
  148. C
  149.       CALL PGSCI(1)
  150.       CALL OUTLIN(1,MXI,1,MXJ,TR)
  151.       CALL PGMTXT('t',1.0,0.0,0.0,'PGIMAG, PGCONT and PGWEDG')
  152.       CALL PGSCH(0.6)
  153.       CALL PGBOX('bctsn',0.0,0,'bctsn',0.0,0)
  154. C
  155. C Draw a wedge.
  156. C
  157.       CALL PGWEDG('BI', 4.0, 5.0, FMIN, FMAX, 'pixel value')
  158.       CALL PGSCH(1.0)
  159. C
  160. C If the device has a cursor, allow user to fiddle with color table.
  161. C
  162.       CALL PGQINF('CURSOR', VAL, L)
  163.       IF (VAL(:L).EQ.'YES') THEN
  164.          CALL FIDDLE
  165.       END IF
  166. C
  167. C Close the device and exit.
  168. C
  169.       CALL PGEND
  170. C-----------------------------------------------------------------------
  171.       END
  172.  
  173.       SUBROUTINE PALETT(TYPE, CONTRA, BRIGHT)
  174. C-----------------------------------------------------------------------
  175. C Set a "palette" of colors in the range of color indices used by
  176. C PGIMAG.
  177. C-----------------------------------------------------------------------
  178.       INTEGER TYPE
  179.       REAL CONTRA, BRIGHT
  180. C
  181.       REAL GL(2), GR(2), GG(2), GB(2)
  182.       REAL RL(9), RR(9), RG(9), RB(9)
  183.       REAL HL(5), HR(5), HG(5), HB(5)
  184.       REAL WL(10), WR(10), WG(10), WB(10)
  185.       REAL AL(20), AR(20), AG(20), AB(20)
  186. C
  187.       DATA GL /0.0, 1.0/
  188.       DATA GR /0.0, 1.0/
  189.       DATA GG /0.0, 1.0/
  190.       DATA GB /0.0, 1.0/
  191. C
  192.       DATA RL /-0.5, 0.0, 0.17, 0.33, 0.50, 0.67, 0.83, 1.0, 1.7/
  193.       DATA RR / 0.0, 0.0,  0.0,  0.0,  0.6,  1.0,  1.0, 1.0, 1.0/
  194.       DATA RG / 0.0, 0.0,  0.0,  1.0,  1.0,  1.0,  0.6, 0.0, 1.0/
  195.       DATA RB / 0.0, 0.3,  0.8,  1.0,  0.3,  0.0,  0.0, 0.0, 1.0/
  196. C
  197.       DATA HL /0.0, 0.2, 0.4, 0.6, 1.0/
  198.       DATA HR /0.0, 0.5, 1.0, 1.0, 1.0/
  199.       DATA HG /0.0, 0.0, 0.5, 1.0, 1.0/
  200.       DATA HB /0.0, 0.0, 0.0, 0.3, 1.0/
  201. C
  202.       DATA WL /0.0, 0.5, 0.5, 0.7, 0.7, 0.85, 0.85, 0.95, 0.95, 1.0/
  203.       DATA WR /0.0, 1.0, 0.0, 0.0, 0.3,  0.8,  0.3,  1.0,  1.0, 1.0/
  204.       DATA WG /0.0, 0.5, 0.4, 1.0, 0.0,  0.0,  0.2,  0.7,  1.0, 1.0/
  205.       DATA WB /0.0, 0.0, 0.0, 0.0, 0.4,  1.0,  0.0,  0.0, 0.95, 1.0/
  206. C
  207.       DATA AL /0.0, 0.1, 0.1, 0.2, 0.2, 0.3, 0.3, 0.4, 0.4, 0.5,
  208.      :         0.5, 0.6, 0.6, 0.7, 0.7, 0.8, 0.8, 0.9, 0.9, 1.0/
  209.       DATA AR /0.0, 0.0, 0.3, 0.3, 0.5, 0.5, 0.0, 0.0, 0.0, 0.0,
  210.      :         0.0, 0.0, 0.0, 0.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0/
  211.       DATA AG /0.0, 0.0, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.8, 0.8,
  212.      :         0.6, 0.6, 1.0, 1.0, 1.0, 1.0, 0.8, 0.8, 0.0, 0.0/
  213.       DATA AB /0.0, 0.0, 0.3, 0.3, 0.7, 0.7, 0.7, 0.7, 0.9, 0.9,
  214.      :         0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0/
  215. C
  216.       IF (TYPE.EQ.1) THEN
  217. C        -- gray scale
  218.          CALL PGCTAB(GL, GR, GG, GB, 2, CONTRA, BRIGHT)
  219.       ELSE IF (TYPE.EQ.2) THEN
  220. C        -- rainbow
  221.          CALL PGCTAB(RL, RR, RG, RB, 9, CONTRA, BRIGHT)
  222.       ELSE IF (TYPE.EQ.3) THEN
  223. C        -- heat
  224.          CALL PGCTAB(HL, HR, HG, HB, 5, CONTRA, BRIGHT)
  225.       ELSE IF (TYPE.EQ.4) THEN
  226. C        -- weird IRAF
  227.          CALL PGCTAB(WL, WR, WG, WB, 10, CONTRA, BRIGHT)
  228.       ELSE IF (TYPE.EQ.5) THEN
  229. C        -- AIPS
  230.          CALL PGCTAB(AL, AR, AG, AB, 20, CONTRA, BRIGHT)
  231.       END IF
  232.       END
  233.  
  234.       SUBROUTINE SETVP
  235. C-----------------------------------------------------------------------
  236. C Set the viewport, allowing margins around the edge for annotation.
  237. C (This is similar in effect to PGVSTD, but has different margins.)
  238. C The routine determines the view-surface size and allocates margins
  239. C as fractions of the minimum of width and height.
  240. C-----------------------------------------------------------------------
  241.       REAL D, VPX1, VPX2, VPY1, VPY2
  242. C
  243.       CALL PGSVP(0.0, 1.0, 0.0, 1.0)
  244.       CALL PGQVP(1, VPX1, VPX2, VPY1, VPY2)
  245.       D = MIN(VPX2-VPX1, VPY2-VPY1)/40.0
  246.       VPX1 = VPX1 + 5.0*D
  247.       VPX2 = VPX2 - 2.0*D
  248.       VPY1 = VPY1 + 8.0*D
  249.       VPY2 = VPY2 - 2.0*D
  250.       CALL PGVSIZ(VPX1, VPX2, VPY1, VPY2)
  251.       END
  252.  
  253.       SUBROUTINE FIDDLE
  254. C
  255.       INTEGER P, IER, PGCURS
  256.       REAL CONTRA, BRIGHT, X, Y, SIGN
  257.       REAL X1, Y1, X2, Y2, B1, B2, C1, C2
  258.       CHARACTER CH
  259. C
  260.       WRITE (*,*) 'Use cursor to adjust color table:'
  261.       WRITE (*,*) ' Keys 1,2,3,4,5 select different palettes'
  262.       WRITE (*,*) ' Key P cycles through available palettes'
  263.       WRITE (*,*) ' Key F adjusts contrast and brightness, with'
  264.       WRITE (*,*) '  cursor x position setting brightness [0.0 - 1.0]'
  265.       WRITE (*,*) '   and y position setting contrast [0.0 - 10.0]'
  266.       WRITE (*,*) '  (Hold down F key while moving cursor to change'
  267.       WRITE (*,*) '  contrast and brightness continuously)'
  268.       WRITE (*,*) ' Key C resets contrast=1.0, brightness=0.5'
  269.       WRITE (*,*) ' Key - reverses color palette'
  270.       WRITE (*,*) ' Key X or right mouse button exits program' 
  271. C
  272.       P = 2
  273.       CONTRA = 1.0
  274.       BRIGHT = 0.5
  275.       X = 0.5
  276.       Y = 1.0
  277.       SIGN = +1.0
  278. C
  279.       CALL PGQWIN(X1, X2, Y1, Y2)
  280.       B1 = 0.0
  281.       B2 = 1.0
  282.       C1 = 0.0
  283.       C2 = 10.0
  284.       CALL PGSWIN(B1, B2, C1, C2)
  285.  10   IER = PGCURS(X, Y, CH)
  286.       IF (CH.EQ.CHAR(0) .OR. CH.EQ.'x' .OR. CH.EQ.'X') THEN
  287.          CALL PGSWIN(X1, X2, Y1, Y2)
  288.          RETURN
  289.       ELSE IF (CH.EQ.'F' .OR. CH.EQ.'f') THEN
  290.          BRIGHT = MAX(B1, MIN(B2,X))
  291.          CONTRA = MAX(C1, MIN(C2,Y))
  292.       ELSE IF (CH.EQ.'C' .OR. CH.EQ.'c') THEN
  293.          CONTRA = 1.0
  294.          Y = 1.0
  295.          BRIGHT = 0.5
  296.          X = 0.5
  297.       ELSE IF (CH.EQ.'-') THEN
  298.          SIGN = -SIGN
  299.       ELSE IF (CH.EQ.'1') THEN
  300.          P = 1
  301.       ELSE IF (CH.EQ.'2') THEN
  302.          P = 2
  303.       ELSE IF (CH.EQ.'3') THEN
  304.          P = 3
  305.       ELSE IF (CH.EQ.'4') THEN
  306.          P = 4
  307.       ELSE IF (CH.EQ.'5') THEN
  308.          P = 5
  309.       ELSE IF (CH.EQ.'P' .OR. CH.EQ.'p') THEN
  310.          P = 1 + MOD(P,5)
  311.       END IF
  312.       CALL PALETT(P, SIGN*CONTRA, BRIGHT)
  313.       GOTO 10
  314.       END
  315.  
  316.       SUBROUTINE FUNC(F, M, N, FMIN, FMAX)
  317.       INTEGER M,N
  318.       REAL F(M,N), FMIN, FMAX
  319. C
  320.       INTEGER I, J
  321.       REAL R
  322. C
  323.       FMIN = 1E30
  324.       FMAX = -1E30
  325.       DO 20 I=1,M
  326.          DO 10 J=1,N
  327.             R = SQRT(REAL(I)**2 + REAL(J)**2)
  328.             F(I,J) = COS(0.6*SQRT(I*80./M)-16.0*J/(3.*N))*
  329.      :           COS(16.0*I/(3.*M))+(I/REAL(M)-J/REAL(N)) + 
  330.      :           0.05*SIN(R)
  331.             FMIN = MIN(F(I,J),FMIN)
  332.             FMAX = MAX(F(I,J),FMAX)
  333.  10      CONTINUE
  334.  20   CONTINUE
  335.       END
  336.  
  337.       SUBROUTINE OUTLIN(I1,I2,J1,J2,TR)
  338.       INTEGER I1,I2,J1,J2
  339.       REAL TR(6)
  340. C-----------------------------------------------------------------------
  341. C Draw the enclosing rectangle of the subarray to be contoured,
  342. C applying the transformation TR.
  343. C
  344. C For a contour map, the corners are (I1,J1) and (I2,J2); for
  345. C a gray-scale map, they are (I1-0.5,J1-0.5), (I2+0.5, J2+0.5).
  346. C-----------------------------------------------------------------------
  347.       INTEGER K
  348.       REAL XW(5), YW(5), T
  349. C
  350.       XW(1) = I1
  351.       YW(1) = J1
  352.       XW(2) = I1
  353.       YW(2) = J2
  354.       XW(3) = I2
  355.       YW(3) = J2
  356.       XW(4) = I2
  357.       YW(4) = J1
  358.       XW(5) = I1
  359.       YW(5) = J1
  360.       DO 10 K=1,5
  361.           T = XW(K)
  362.           XW(K) = TR(1) + TR(2)*T + TR(3)*YW(K)
  363.           YW(K) = TR(4) + TR(5)*T + TR(6)*YW(K)
  364.    10 CONTINUE
  365.       CALL PGLINE(5,XW,YW)
  366.       END
  367.